home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / ada / adaed_1_.z / adaed_1_ / Adaed-1.11.0a / blib.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  33.4 KB  |  1,172 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "libhdr.h"
  14. #include "vars.h"
  15. #include "segment.h"
  16. #include "gvars.h"
  17. #include "ops.h"
  18. #include "type.h"
  19. #include "ifile.h"
  20. #include "axqrprots.h"
  21. #include "genprots.h"
  22. #include "segmentprots.h"
  23. #include "ginterprots.h"
  24. #include "setprots.h"
  25. #include "bmainprots.h"
  26. #include "gutilprots.h"
  27. #include "dclmapprots.h"
  28. #include "libprots.h"
  29. #include "libfprots.h"
  30. #include "librprots.h"
  31. #include "glibprots.h"
  32. #include "miscprots.h"
  33. #include "gmiscprots.h"
  34. #include "smiscprots.h"
  35. #include "gnodesprots.h"
  36. #include "blibprots.h"
  37.  
  38. #ifdef vms
  39. #define vms_BINDER
  40. #endif
  41.  
  42. #ifdef vms_BINDER
  43. /*
  44. #include "adabind.h"
  45. */
  46. #include descrip
  47. struct      dsc$descriptor_s unit_name_desc;
  48. #endif
  49.  
  50. static void update_elaborate(char *);
  51. static void main_code_segment();
  52. static Tuple delayed_map_get(int);
  53. static void delayed_map_put(int, Tuple);
  54. static void delayed_map_undef(int);
  55. static void add_code(char *);
  56. static int needs_body_bnd(char *);
  57. static int depth_level(char *);
  58. static Tuple build_relay_sets(char *, int);
  59. static void update_subunit_context(char *);
  60. static int load_binding_unit(char *);
  61. static char *read_binding_ais(char *, char *);
  62.  
  63. extern int ADA_MIN_INTEGER, ADA_MAX_INTEGER;
  64. extern int adacomp_option;
  65. extern long ADA_MIN_FIXED, ADA_MAX_FIXED;
  66. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  67. extern IFILE *AXQFILE, *LIBFILE, *AISFILE, *STUBFILE;
  68.  
  69. /* variables used only by binder */
  70. static Symbol    mainunit_sym;
  71.  
  72. int binder(Tuple aisread_tup)                                    /*;binder*/
  73. {
  74.     /*
  75.      * BINDER checks the program library of a given main program for
  76.      * completeness.  Missing modules are printed.
  77.      * Otherwise, idle_task and main_task are generated. idle_task calls
  78.      * the initialization procedures required to elaborate the various
  79.      * units in (one of) the order(s) prescribed by the language
  80.      */
  81.  
  82.     char    *name, *body, *main_name, *s_name;
  83.     int        prior, unit, name_num, delayed_unit;
  84.     Set        elaborated, idle_precedes, precedes;
  85.     struct unit *pUnit;
  86.     Tuple    missing_units, to_check, to_bind, u_slots, tup;
  87.     Tuple    elaboration_table, compiled_units, delayed, s, u_rs;
  88.     Fortup    ft1;
  89.     Forset    fs1;
  90.     Unitdecl    ud;
  91.     int        i, n;
  92.     int         is_interfaced_bind_unit_now;
  93.  
  94. #ifdef DEBUG
  95.     Tuple       axq_needed; /* list of predefined units */
  96. #endif
  97.  
  98.     /* Reset global tuple of node and symbols for binder. */
  99.     seq_node_n = 0;
  100.     seq_node = tup_new(SEQ_NODE_INC);
  101.     seq_symbol_n = 0;
  102.  
  103.     /*  Miscelleanous variables needed for code generation */
  104.     LOCAL_REFERENCE_MAP =  local_reference_map_new();
  105.     RELAY_SET = tup_new(0);
  106.     /*
  107.      * POSITION and PATCHES is stored in EMAP and is set implicitly when a new
  108.      * EMAP is created for a symbol and therefore is not needed here.
  109.      *
  110.      * POSITION     = {};
  111.      * PATCHES     = {};
  112.      */
  113.     CURRENT_LEVEL = 0;
  114.     LAST_OFFSET     = 0;
  115.     MAX_OFFSET     = 0;
  116.  
  117.     call_lib_unit = tup_new(0);
  118.  
  119.     if (streq(MAINunit, "")) {
  120.         to_check = tup_new(0);
  121.         /* collect all possible main units i.e. all parameterless subprograms
  122.          * which are not proper bodies (subunits).
  123.          */
  124.         for (i = 15; i <= unit_numbers; i++) {
  125.             struct unit *pUnit = pUnits[i];
  126.             if (pUnit->isMain && !streq("ma", unit_name_type(pUnit->name)))
  127.                 to_check = tup_with(to_check,pUnit->name);
  128.         }
  129.         if (tup_size(to_check) == 0) {
  130. #ifdef vms
  131.             if (adacomp_option)
  132.                 user_error("No subprogram in library");
  133.             else {
  134.                 LIB$SIGNAL(MSG_NOSUBPROG);
  135.                 exit();
  136.             }
  137. #else
  138.             user_error("No subprogram in library");
  139. #endif
  140.             return FALSE;
  141.         }
  142.         else if (tup_size(to_check) == 1) {
  143.             main_name = tup_frome(to_check);
  144.             MAINunit  = unit_name_name(main_name);
  145.         }
  146.         else {
  147. #ifdef vms
  148.             if (adacomp_option) {
  149.                 user_error(
  150.                   "Several subprograms in library please specify main from:");
  151.             }
  152.             else {
  153.                 LIB$SIGNAL(MSG_MANYMAIN);
  154.                 unit_name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  155.                 unit_name_desc.dsc$b_class = DSC$K_CLASS_S;
  156.             }
  157. #else
  158.             user_error(
  159.                   "Several subprograms in library please specify main from:");
  160. #endif
  161.             FORTUP(name = (char *), to_check, ft1);
  162. #ifdef vms
  163.                 if (adacomp_option) {
  164.                     user_info(unit_name_name(name));
  165.                 }
  166.                 else {
  167.                     unit_name_desc.dsc$a_pointer = unit_name_name(name);
  168.                     unit_name_desc.dsc$w_length =
  169.                       strlen(unit_name_desc.dsc$a_pointer);
  170.                     LIB$SIGNAL(MSG_UNITNAME, 1, &unit_name_desc);
  171.                 }
  172. #else
  173.                 user_info(unit_name_name(name));
  174. #endif
  175.             ENDFORTUP(ft1);
  176. #ifdef vms
  177.             if (adacomp_option)
  178.                 return FALSE;
  179.             else 
  180.                 exit();
  181. #else
  182.             return FALSE;
  183. #endif
  184.         }
  185.     }
  186.     else {
  187.         main_name = strjoin("su", MAINunit);
  188.     }
  189.  
  190.     if (!load_binding_unit(main_name)) {
  191.         /* message cannot retrieve... already printed */
  192.         return FALSE;
  193.     }
  194.     update_elaborate(main_name);
  195.     ud = unit_decl_get(main_name);
  196.     mainunit_sym = ud->ud_unam;
  197.     if (NATURE(mainunit_sym) != na_procedure    /* only procedures */
  198.       || tup_size(SIGNATURE(mainunit_sym)) != 0) {    /* without parameters */
  199. #ifdef vms
  200.         if (adacomp_option) {
  201.             user_error(strjoin(formatted_name(main_name),
  202.               " is not a valid main program."));
  203.         }
  204.         else {
  205.             unit_name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  206.             unit_name_desc.dsc$b_class = DSC$K_CLASS_S;
  207.             unit_name_desc.dsc$a_pointer = formatted_name(main_name);
  208.             unit_name_desc.dsc$w_length = strlen(unit_name_desc.dsc$a_pointer);
  209.             LIB$SIGNAL(MSG_NOTMAIN, 1, &unit_name_desc);
  210.             exit();
  211.         }
  212. #else
  213.         user_error(strjoin(formatted_name(main_name),
  214.           " is not a valid main program."));
  215. #endif
  216.         return FALSE;
  217.     }
  218.     name  = strjoin(MAINunit, "_idle_task");
  219.     /* The name of the binding unit is "ma" followed by the name */
  220.     /* In SETL unit_name was ['main_unit', name] */
  221.     /* Note that this may create a new unit */
  222.     unit_name      = strjoin("ma", name);
  223.     unit_number_now  = unit_number(unit_name);
  224.     lib_unit_put(unit_name, AISFILENAME);
  225.  
  226.     /*    Symbol table initialized with 'main_task_type' */
  227.  
  228.     symbol_main_task_type = sym_new(na_task_type);
  229.     TYPE_OF(symbol_main_task_type) = symbol_main_task_type;
  230.     SIGNATURE(symbol_main_task_type) = tup_new(0);
  231.     ALIAS(symbol_main_task_type) = symbol_main_task_type;
  232.     ORIG_NAME(symbol_main_task_type) = "main_task_type";
  233.     DECLARED(symbol_main_task_type) = dcl_new(0);
  234.     TYPE_KIND(symbol_main_task_type) = TK_WORD;
  235.     TYPE_SIZE(symbol_main_task_type) = su_size(TK_WORD);
  236. #ifdef TBSL
  237.     /* REFERENCE_MAP = {['main_task_type', [1, 47]]}; */
  238.     S_SEGMENT(symbol_main_task_type) = 1;
  239.     S_OFFSET(symbol_main_task_type)  = 47;
  240. #endif
  241.     MISC(symbol_main_task_type) = (char *)TRUE;
  242.  
  243.     /* Here we duplicate that part of the code from init_gen needed
  244.      * when starting a new unit
  245.      *
  246.      * Set initial unit_slots map to null value 
  247.      * assume unit_number_now gives curent unit number; the correct
  248.      * assignment of this may best be done elsewhere
  249.      */
  250.     tup = tup_new(5);
  251.     for (i = 1; i <= 5; i++)
  252.         tup[i] = (char *) tup_new(0);
  253.     unit_slots_put(unit_number_now, tup);
  254.     to_check      = tup_new1(main_name);
  255.     idle_precedes  = set_new1((char *) unit_numbered(main_name));
  256.     to_bind      = tup_new(0);
  257.     missing_units  = tup_new(0);
  258.     compiled_units = tup_new(unit_numbers);
  259.     for (i = 1; i <= unit_numbers; i++)
  260.         compiled_units[i] = pUnits[i]->libUnit;
  261.  
  262.     /* check that any needed unit has been compiled. 
  263.      *
  264.      * All units needed (directly or indirectly) by main_name are checked. 
  265.      * The order in which these checks are performed is unimportant. The 
  266.      * ordering map 'precedes' has been loaded from library, for later use 
  267.      * in a topological sort. 
  268.      *
  269.      * All units needed, but not referenced by with clauses (typically 
  270.      * package bodies, procedure bodies and subunits) are noted into 
  271.      * idle_precedes to make later idle_task depend on them, in order to 
  272.      * suppress the binding unit if they are recompiled. 
  273.      */
  274.  
  275.     while (tup_size(to_check)!= 0) {
  276.  
  277.         /* always load the item at the front of the queue so that specs are
  278.          * read before their bodies.
  279.          * TBSL: this is due to the fact that the body sometimes contains
  280.          * info that is not in the spec(e.g. ASSOC_SYMBOLS) and since they share
  281.          * the same symbol the info would be overridden by the spec if the spec 
  282.          * was read last.
  283.          */
  284.         name = tup_fromb(to_check);
  285.         if (is_generic(name))
  286.             continue;
  287.  
  288.         /* Check to see whether a package specification requires a body and
  289.          * if yes, that the body has been compiled.
  290.          */
  291.         if (streq(unit_name_type(name), "sp")
  292.           || streq(unit_name_type(name), "bo")) {
  293.             /* AXQ needed */
  294.             if (!load_binding_unit(name))
  295.                 missing_units = tup_with(missing_units, name);
  296.             else
  297.                 update_elaborate(name);
  298.         }
  299.         /* Collect the stubs of the current unit. */
  300.         s = stubs(name);
  301.         /*
  302.          * to_check      +:= s;
  303.          * missing_units +:= s - compiled_units;  
  304.          * idle_precedes +:= s;
  305.          */
  306.         FORTUP(s_name = (char *), s, ft1);
  307.              if (!tup_memstr(s_name, to_check))
  308.                  to_check = tup_with(to_check, s_name);
  309.              if (!tup_memstr(s_name, compiled_units))
  310.                  missing_units = tup_with(missing_units, s_name);
  311.              idle_precedes = set_with(idle_precedes,
  312.                (char *) unit_numbered(s_name));
  313.         ENDFORTUP(ft1);
  314.  
  315.         if (streq(unit_name_type(name), "sp")) {
  316.             body = strjoin("bo", unit_name_name(name));
  317.             if (tup_memstr(body, compiled_units)) {
  318.                 to_check = tup_with(to_check, body);
  319.                 idle_precedes = set_with(idle_precedes,
  320.                   (char *)unit_numbered(body));
  321.             }
  322.             else if (needs_body_bnd(name))
  323.                 missing_units = tup_with(missing_units, body);
  324.         }
  325.         else if (streq(unit_name_type(name), "ss")) {
  326.             /* Suprogram body must be present.*/
  327.             body = strjoin("su", unit_name_name(name));
  328.             if (tup_memstr(body, compiled_units) && load_binding_unit(body)) {
  329.                 to_check = tup_with(to_check, body);
  330.                 update_elaborate(body);
  331.             }
  332.             else
  333.                 missing_units = tup_with(missing_units, body);
  334.             idle_precedes = set_with(idle_precedes,
  335.               (char *) unit_numbered(body));
  336.         }
  337.  
  338.         else if (streq(unit_name_type(name), "su")) {
  339.             if (is_subunit(name)) {     /* no previous unit spec, of course. */
  340.                 if (load_binding_unit(name))
  341.                     update_elaborate(name);
  342.             }
  343.             else if (!tup_memstr(name, compiled_units))   /* no previous spec */
  344.                 missing_units = tup_with(missing_units, name);
  345.         }
  346.  
  347.         /* Check the units indicated by visibility lists (precedes).
  348.          *  
  349.          * loop forall prior in precedes{name} | prior notin to_bind do
  350.          *    to_check with= prior;
  351.          * end loop forall;
  352.          */
  353.         precedes = precedes_map_get(name);
  354.         FORSET(prior = (int), precedes, fs1);
  355.              if (!tup_memstr(pUnits[prior]->name, to_bind))
  356.                  to_check = tup_with(to_check, pUnits[prior]->name);
  357.         ENDFORSET(fs1);
  358.  
  359.         if (is_subunit(name) && tup_memstr(name, compiled_units))
  360.             update_subunit_context(name);
  361.  
  362.         to_bind = tup_with(to_bind, name);
  363.  
  364.     } /* end while */
  365.  
  366.     /* If compilation units are missing, report them and return. */
  367.  
  368.     if (tup_size(missing_units) != 0) {
  369. #ifdef vms
  370.         if (adacomp_option) {
  371.             user_error("Missing units in library:");
  372.         }
  373.         else {
  374.             LIB$SIGNAL(MSG_MISSUNIT);
  375.             unit_name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  376.             unit_name_desc.dsc$b_class = DSC$K_CLASS_S;
  377.         }
  378. #else
  379.         user_error("Missing units in library:");
  380. #endif
  381.         FORTUP(name = (char *), missing_units, ft1);
  382. #ifdef vms
  383.             if (adacomp_option) {
  384.                 user_info(formatted_name(name));
  385.             }
  386.             else {
  387.                 unit_name_desc.dsc$a_pointer = formatted_name(name);
  388.                 unit_name_desc.dsc$w_length =
  389.                   strlen(unit_name_desc.dsc$a_pointer);
  390.                 LIB$SIGNAL(MSG_UNITNAME, 1, &unit_name_desc);
  391.             }
  392. #else
  393.             user_info(formatted_name(name));
  394. #endif
  395.         ENDFORTUP(ft1);
  396. #ifdef vms
  397.         if (adacomp_option)
  398.             return FALSE;
  399.         else
  400.             exit();
  401. #else
  402.         return FALSE;
  403. #endif
  404.     }
  405.     if (tup_size(interfaced_procedures) != 0) {
  406.         int i, j, n, m;
  407.         n = tup_size(interfaced_procedures);
  408.         m = tup_size(to_bind);
  409.         for (i = 1; i <= n; i += 2) {
  410.             for (j = 1; j <= m; j++) {
  411.                 if((int)interfaced_procedures[i] == unit_numbered(to_bind[j])) {
  412.                     /* the field of is_main which is usualy always 0 for a
  413.                      * binding unit is set to 1 in this case to specify that
  414.                      * this binding unit calls an interfaced subprogram
  415.                      */
  416.                     pUnits[unit_number_now]->isMain = 1;
  417.                     is_interfaced_bind_unit_now = 1;
  418.                     break;
  419.                 }
  420.                 else {
  421.                     is_interfaced_bind_unit_now = 0;
  422.                 }
  423.             }
  424.         }
  425.     }
  426.     else {
  427.         is_interfaced_bind_unit_now = 0;
  428.     }
  429.  
  430.     if (is_interfaced_bind_unit_now) geninter(to_bind);
  431.     /*
  432.      * call_lib_unit is built in an order consistent with the rules for 
  433.      * the elaboration of library units. 
  434.      * The algorithm tries to use the compilation order, unless some unit 
  435.      * depends on a not yet elaborated unit. In that case, it is appended 
  436.      * to a list of units depending on one of the not yet elaborated units 
  437.      * When this unit is elaborated, one tries again to elaborate units 
  438.      * depending on it. 
  439.      * If a unit depends on one of its own delayed units, it is a 
  440.      * circularity 
  441.      * elaborated: set of already elaborated units 
  442.      * delayed     : map from units to the list of dependant units. 
  443.      */
  444.  
  445.     /* Use the compilation order */
  446.     /* TBSL: for now we elaborate all units even if we don't use them.
  447.      * a better scheme is to have elaboration_table be only units we need.
  448.      */
  449.     elaboration_table = tup_copy(compilation_table);
  450.     elaborated         = set_new1((char *)0);
  451.     DELAYED_MAP      = tup_new(0);
  452. #ifdef DEBUG
  453.     axq_needed        = tup_new(0);
  454. #endif
  455.  
  456.     while (tup_size(elaboration_table) != 0) {
  457.         name_num = (int) tup_fromb(elaboration_table);
  458.         name = pUnits[name_num]->name;
  459.  
  460.         if (is_generic(name) || is_subunit(name)) {
  461.             /* Generics are not elaborated 
  462.              * subunits are elaborated from the parent 
  463.              */
  464.             elaborated = set_with(elaborated, (char *) name_num);
  465.         }
  466.         else if (!tup_memstr(name, to_bind)) {
  467.             /* Don't need this unit */
  468.         }
  469.         else if (set_subset(precedes_map_get(name), elaborated)) {
  470.             /* May elaborate this unit now */
  471.             add_code(name);
  472.             elaborated = set_with(elaborated, (char *) name_num);
  473. #ifdef TBSL
  474.             if (name_num < 11) { /* predef unit */
  475. #endif
  476.             /*
  477.              * if (name in domain delayed) then 
  478.              * -- Retry units depending on this one 
  479.              *   elaboration_table := delayed(name) + elaboration_table;
  480.              *   delayed(name) := OM;
  481.              * end if;
  482.              */
  483.             n = tup_size(DELAYED_MAP);
  484.             for (i = 1; i <= n; i += 2) {
  485.                 if (DELAYED_MAP[i] == (char *)name_num) {
  486.                     /* Retry units depending on this one */
  487.                     elaboration_table=
  488.                       tup_add(delayed_map_get(name_num), elaboration_table);
  489.                     delayed_map_undef(name_num);
  490.                     break;
  491.                 }
  492.             }
  493.         }
  494.         else {
  495.             /* Depends on a not yet elaborated unit => delay elaboration */
  496.             precedes = precedes_map_get(name);
  497.             unit     = (int) set_arb(set_diff(precedes, elaborated));
  498.             /* delayed(unit) = (delayed(unit) ? []) with name; */
  499.             delayed = delayed_map_get(unit);
  500.             if (delayed == (Tuple)0)
  501.                 delayed_map_put(unit, tup_new1((char *) name_num));
  502.             else
  503.                 delayed_map_put(unit, tup_with(delayed, (char *)name_num));
  504.             /* TBSL: This code to be removed when predef is handled correctly */
  505.             if (name_num < num_predef_units) {
  506.                 elaboration_table =
  507.                   tup_add(tup_new1((char *)unit), elaboration_table);
  508.             }
  509.         }
  510.     } /* end while */
  511.  
  512.     /* Check for circularity among units */
  513.     n = tup_size(DELAYED_MAP);
  514.     if (n != 0) {
  515. #ifdef vms
  516.         if (adacomp_option)
  517.             user_error("Circularity detected among these units:");
  518.         else {
  519.             LIB$SIGNAL(MSG_CIRCULAR);
  520.             unit_name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  521.             unit_name_desc.dsc$b_class = DSC$K_CLASS_S;
  522.         }
  523. #else
  524.         user_error("Circularity detected among these units:");
  525. #endif
  526.         for (i = 1; i <= n; i += 2) {
  527.             delayed = (Tuple) DELAYED_MAP[i+1];
  528.             FORTUP(delayed_unit = (int), delayed, ft1);
  529. #ifdef vms
  530.                 if (adacomp_option)
  531.                     user_info(formatted_name(pUnits[delayed_unit]->name));
  532.                 else {
  533.                     unit_name_desc.dsc$a_pointer = 
  534.                       formatted_name(pUnits[delayed_unit]->name);
  535.                     unit_name_desc.dsc$w_length =
  536.                       strlen(unit_name_desc.dsc$a_pointer);
  537.                     LIB$SIGNAL(MSG_UNITNAME, 1, &unit_name_desc);
  538.                 }
  539. #else
  540.                 user_info(formatted_name(pUnits[delayed_unit]->name));
  541. #endif
  542.             ENDFORTUP(ft1);
  543.         }
  544. #ifdef vms
  545.         if (adacomp_option)
  546.             return FALSE;
  547.         else
  548.             exit();
  549. #else
  550.         return FALSE;
  551. #endif
  552.     }
  553.  
  554.     /* Everything is OK: build idle and main task */
  555.  
  556. #ifdef TBSL
  557.     axqfiles_read = tup_with(axqfiles_read, AXQfile);
  558.     aisread_tup(1)    with= unit_name;
  559. #endif
  560.  
  561.     CURRENT_DATA_SEGMENT = 1;
  562.     CURRENT_CODE_SEGMENT = 1;
  563. #ifdef MACHINE_CODE
  564.     if (list_code) {
  565.         to_gen(" ");
  566.         to_gen(" ");
  567.         to_gen_unam("============== UNIT : ", formatted_name(unit_name),
  568.           " ==============");
  569.         to_gen(" ");
  570.         to_gen("--- Idle task ---");
  571.         to_gen_int("    data slot # ", CURRENT_DATA_SEGMENT);
  572.         to_gen_int("    code slot # ", CURRENT_CODE_SEGMENT);
  573.         to_gen(" ");
  574.     }
  575. #endif
  576.     u_slots = tup_new(5);
  577. #ifdef DEBUG
  578.     if(tup_size(axq_needed)) { /* binding requiring predef data segments */
  579.         tup = read_predef_axq(axq_needed);
  580.         u_slots[SLOTS_DATA] = (char *)tup_with((Tuple) tup[1],
  581.           (char *)CURRENT_DATA_SEGMENT);
  582.         u_slots[SLOTS_CODE] = (char *)tup_with((Tuple) tup[2],
  583.           (char *)CURRENT_CODE_SEGMENT);
  584.     }
  585.     else { /* library option or no predefined unit needed */
  586.         u_slots[SLOTS_DATA] = (char *)tup_new1((char *)CURRENT_DATA_SEGMENT);
  587.         u_slots[SLOTS_CODE] = (char *)tup_new1((char *)CURRENT_CODE_SEGMENT);
  588.     }
  589. #else
  590.     u_slots[SLOTS_DATA] = (char *)tup_new1((char *)CURRENT_DATA_SEGMENT);
  591.     u_slots[SLOTS_CODE] = (char *)tup_new1((char *)CURRENT_CODE_SEGMENT);
  592. #endif
  593.     u_slots[SLOTS_EXCEPTION] = (char *)tup_new(0);
  594.     u_slots[SLOTS_DATA_BORROWED] = (char *)tup_new(0);
  595.     u_slots[SLOTS_CODE_BORROWED] = (char *)tup_new(0);
  596.     unit_slots_put(unit_number_now, u_slots);
  597.  
  598.     precedes_map_put(unit_name, idle_precedes);
  599.  
  600.     DATA_SEGMENT = DATA_SEGMENT_MAIN;
  601.  
  602.     /* Compute the relay sets of subunits: 
  603.      *
  604.      * loop forall name in to_bind | not is_subunit(name) do
  605.      *  [-, u_rs] = build_relay_sets(name, 1);
  606.      *  if (u_rs !== []) then 
  607.      *     COMPILER_ERROR ("Relay set at level 1 in "+formatted_name(name));
  608.      *    if debug_flag then
  609.      *       gen_trace("BINDER", u_rs);
  610.      *    end if;
  611.      *  end if;
  612.      * end loop;
  613.      */
  614.  
  615.     FORTUP(name = (char *), to_bind, ft1);
  616.         if (!is_subunit(name)) {
  617.             tup = build_relay_sets(name, 1);
  618.             u_rs = (Tuple) tup[2];
  619.             if (tup_size(u_rs) != 0) {
  620.                 compiler_error (
  621.                   strjoin("Relay set at level 1 in ", formatted_name(name)));
  622.             }
  623.         }
  624.     ENDFORTUP(ft1);
  625.  
  626.     main_code_segment();
  627.     /* Update library */
  628.  
  629.     /* OWNED_SLOTS(unit_name)(2) with= CURRENT_CODE_SEGMENT; */
  630.     u_slots[SLOTS_CODE] = (char *)tup_with((Tuple) u_slots[SLOTS_CODE],
  631.       (char *)CURRENT_CODE_SEGMENT);
  632.  
  633. #ifdef TBSL
  634.     LIB_UNIT (unit_name) = [NODE_COUNT, '' , AXQfile]
  635.        + OWNED_SLOTS(unit_name);
  636.     PRE_COMP (unit_name) = idle_precedes;
  637.     COMP_DATE(unit_name) = {
  638. [name, COMP_DATE(name)(name)] :
  639.         name in idle_precedes * compiled_units        };
  640.     today = DATE;
  641.     COMP_DATE(unit_name)(unit_name) =
  642.         [today(9..17), today(20..27), #aisread_tup(1)];
  643. #endif
  644.  
  645.     /* DATA_SEGMENT_MAP(CURRENT_DATA_SEGMENT) = DATA_SEGMENT; */
  646.     DATA_SEGMENT_MAP = 
  647.       segment_map_put(DATA_SEGMENT_MAP, CURRENT_DATA_SEGMENT, DATA_SEGMENT);
  648.  
  649.     compilation_table = tup_with(compilation_table, (char *)unit_number_now);
  650.     pUnit = pUnits[unit_number_now];
  651.     pUnit->aisInfo.numberSymbols = seq_symbol_n;
  652.     pUnit->aisInfo.symbols = (char *) tup_new(seq_symbol_n);
  653. #ifdef MACHINE_CODE
  654.     if (list_code) print_data_segment();
  655. #endif
  656.     return TRUE;
  657. }
  658.  
  659. static void update_elaborate(char *name)                /*;update_elaborate*/
  660. {
  661.     Set      precedes;
  662.     Tuple  pragma_tup;
  663.     char      *unam;
  664.     int      unit, name_num;
  665.     Fortup ft1;
  666.  
  667.     name_num = unit_numbered(name);
  668.     pragma_tup = (Tuple) pUnits[name_num]->aisInfo.pragmaElab;
  669.     precedes = (Set) precedes_map_get(name);
  670.     FORTUP(unam = (char *), pragma_tup, ft1);
  671.         unit = unit_numbered(unam);
  672.         /* if the pragma names a unit which is not explicitly present (unit is 0
  673.          * or the body may be obsolete) ignore it
  674.          */
  675.         if (unit != 0) {
  676.             if (streq(pUnits[unit]->libInfo.obsolete, "ok"))
  677.                 precedes = set_with(precedes, (char *) unit);
  678.         }
  679.     ENDFORTUP(ft1);
  680.     precedes_map_put(name, precedes);
  681. }
  682.  
  683. static void main_code_segment()                        /*;main_code_segment */
  684. {
  685.     Node  call_node;
  686.     Symbol      loop_name;
  687.     Segment    task_id;
  688.     Symbol     handler1, handler2, handler3;
  689.     Fortup    ft1;
  690.  
  691.     /* check that symbol_main_task_type defined */
  692.     if (symbol_main_task_type == (Symbol)0)
  693.         chaos("glib.c main_code_segment  symbol_main_task_type not defined");
  694.  
  695.     CODE_SEGMENT = segment_new(SEGMENT_KIND_CODE, 0);
  696.     gen_c(I_NOP, "no handling; go to task trap");
  697.     gen(I_NOP);
  698.     gen_ic(I_TERMINATE, 6, "task trap in case of dead-lock");
  699.  
  700.     symbol_main_task = sym_new(na_obj);
  701.     ORIG_NAME(symbol_main_task) = strjoin("main_task", "");
  702.     new_symbol(symbol_main_task, na_obj, symbol_main_task_type, (Tuple)0,
  703.       (Symbol)0);
  704.     task_id = segment_new(SEGMENT_KIND_DATA, 1);
  705.     segment_put_word(task_id, 0);
  706.     next_global_reference_segment(symbol_main_task, task_id);
  707.     gen(I_ENTER_BLOCK);
  708.     gen_s(I_CREATE_TASK, symbol_main_task_type);
  709.     gen_ks(I_POP, kind_of(symbol_main_task_type), symbol_main_task);
  710.     gen(I_ACTIVATE);
  711.     loop_name = new_unique_name("endless_loop");
  712.     gen_s(I_LABEL, loop_name);
  713.     gen_s(I_JUMP, loop_name);
  714.     gen(I_EXIT_BLOCK);
  715.     gen(I_END);         /* flush peep-hole buffer */
  716.  
  717.     /*CODE_SEGMENT_MAP(CURRENT_CODE_SEGMENT) = CODE_SEGMENT;*/
  718.     CODE_SEGMENT_MAP = segment_map_put(CODE_SEGMENT_MAP, CURRENT_CODE_SEGMENT,
  719.       CODE_SEGMENT);
  720.  
  721.     CURRENT_CODE_SEGMENT = MAIN_CS;
  722. #ifdef MACHINE_CODE
  723.     if (list_code) {
  724.         to_gen(" ");
  725.         to_gen(" ");
  726.         to_gen("--- Main task ---");
  727.         to_gen_int("       code slot # ", CURRENT_CODE_SEGMENT);
  728.         to_gen(" ");
  729.     }
  730. #endif
  731.     CODE_SEGMENT = segment_new(SEGMENT_KIND_CODE, 0);
  732.     gen(I_LEAVE_BLOCK);
  733.     gen(I_RAISE);
  734.     gen_ic(I_TERMINATE, 5, "never used");
  735.     gen(I_ENTER_BLOCK);
  736.     gen_ic(I_END_ACTIVATION, 1, "Ok");
  737.     handler1 = new_unique_name("handler");
  738.     gen_s(I_INSTALL_HANDLER, handler1);
  739.     gen(I_ENTER_BLOCK);
  740.     FORTUP(call_node = (Node), call_lib_unit, ft1);
  741.         if (N_KIND(call_node) == as_activate_spec) {
  742.             gen_ks(I_PUSH, mu_word, N_UNQ(N_AST1(call_node)));
  743.             gen(I_LINK_TASKS_DECLARED);
  744.             gen(I_ACTIVATE);
  745.         }
  746.         else {
  747.             gen_s(I_CALL, N_UNQ(N_AST1(call_node)));
  748.         }
  749.     ENDFORTUP(ft1);
  750.     handler2 = new_unique_name("handler");
  751.     gen_s(I_INSTALL_HANDLER, handler2);
  752.     gen_s(I_CALL, mainunit_sym);
  753.     gen(I_EXIT_BLOCK);
  754.     handler3 = new_unique_name("end_handler");
  755.     gen_s(I_JUMP, handler3);
  756.     gen_s(I_LABEL, handler2);
  757.     gen_ic(I_TERMINATE, 4, "unhandled exception in main");
  758.     gen_s(I_LABEL, handler3);
  759.     gen(I_EXIT_BLOCK);
  760.     handler3 = new_unique_name("end_handler");
  761.     gen_s(I_JUMP, handler3);
  762.     gen_s(I_LABEL, handler1);
  763.     gen_ic(I_TERMINATE, 3, "exception in library unit elaboration");
  764.     gen_s(I_LABEL, handler3);
  765.     gen_ic(I_TERMINATE, 5, "library tasks are completed");
  766.     gen_ic(I_DATA, 0, "size of local objects");
  767.     gen(I_END);         /* flush peep-hole buffer */
  768.  
  769.     /*CODE_SEGMENT_MAP(CURRENT_CODE_SEGMENT) = CODE_SEGMENT;*/
  770.     CODE_SEGMENT_MAP = segment_map_put(CODE_SEGMENT_MAP, CURRENT_CODE_SEGMENT,
  771.       CODE_SEGMENT);
  772. }
  773.  
  774. static Tuple delayed_map_get(int unum)                    /*;delayed_map_get*/
  775. {
  776.     int        i, n;
  777.  
  778.     n = tup_size(DELAYED_MAP);
  779.     for (i = 1; i <= n; i += 2) {
  780.         if (DELAYED_MAP[i] == (char *)unum)
  781.             return (Tuple) DELAYED_MAP[i+1];
  782.     }
  783.     return (Tuple)0;
  784. }
  785.  
  786. static int needs_body_bnd(char *name)                            /*;needs_body */
  787. {
  788.     Unitdecl ud;
  789.     Tuple   tup;
  790.     Symbol  unit_unam;
  791.  
  792.     ud = unit_decl_get(name);
  793.     /* A spec which is obsolete needs no body */
  794.     if (ud == (Unitdecl)0) return FALSE;
  795.     unit_unam = ud->ud_unam;
  796.     tup = (Tuple) MISC(unit_unam);
  797.     return ((int)tup[2] != 0);
  798. }
  799.  
  800. static void delayed_map_put(int unum, Tuple ntup)            /*;delayed_map_put*/
  801. {
  802.     int        i, n;
  803.  
  804.     n = tup_size(DELAYED_MAP);
  805.     for (i = 1; i <= n; i += 2) {
  806.         if (DELAYED_MAP[i] == (char *) unum) {
  807.             DELAYED_MAP[i+1] = (char *) ntup;
  808.             return;
  809.         }
  810.     }
  811.     DELAYED_MAP = tup_exp(DELAYED_MAP, n + 2);
  812.     DELAYED_MAP[n+1] = (char *) unum;
  813.     DELAYED_MAP[n+2] = (char *) ntup;
  814. }
  815.  
  816. static void delayed_map_undef(int unum)                    /*;delayed_map_undef*/
  817. {
  818.     int    i, n;
  819.  
  820.     n = tup_size(DELAYED_MAP);
  821.     for (i = 1; i <= n; i += 2) {
  822.         if (DELAYED_MAP[i] == (char *) unum) {
  823.             DELAYED_MAP[i] = DELAYED_MAP[n-1];
  824.             DELAYED_MAP[i+1] = DELAYED_MAP[n];
  825.             DELAYED_MAP[0] = (char *) (n-2);
  826.             return;
  827.         }
  828.     }
  829. }
  830.  
  831. static void add_code(char *name)                                /*;add_code*/
  832. {
  833.     /*
  834.      * Adds to call_lib_unit the calls required to elaborate packages.
  835.      * Library subprograms never need elaboration.
  836.      * Subunits are elaborated in the parent unit at the location of the
  837.      * correponding stub.
  838.      */
  839.  
  840.     Unitdecl    ud;
  841.     Symbol    unit_unam;
  842.     Node        act_node;
  843.     char        *unit_kind, *body;
  844.     int            has_body, i;
  845.     /* Late generic instantiations : TBSL */
  846.  
  847.     unit_kind = unit_name_type(name);
  848.     /* elaboration only needed for packages */
  849.     if (!streq(unit_kind, "sp") && !streq(unit_kind, "bo")) return;
  850.  
  851.     ud = unit_decl_get(name);
  852.     unit_unam = ud->ud_unam;
  853.  
  854.     if (streq(unit_kind, "sp")) {
  855.         call_lib_unit = tup_with(call_lib_unit, (char *) new_call_node(
  856.           assoc_symbol_get(unit_unam, INIT_SPEC), tup_new(0), symbol_none));
  857.         body = strjoin("bo", unit_name_name(name));
  858.         has_body = FALSE;
  859.         for (i = 1; i <= unit_numbers; i++)
  860.             if (streq(body, pUnits[i]->name)) {
  861.                 has_body = TRUE;
  862.                 break;
  863.             }
  864.         if (lib_package_with_tasks(unit_unam)    /* spec declares tasks */
  865.           && !has_body) {        /* but has no body */
  866.             act_node = new_node(as_activate_spec);
  867.             N_AST1(act_node) = new_name_node(assoc_symbol_get(unit_unam,
  868.               INIT_TASKS));
  869.             call_lib_unit = tup_with(call_lib_unit, (char *) act_node);
  870.         }
  871.     }
  872.     else if (streq(unit_kind, "bo")) {
  873.         call_lib_unit = tup_with(call_lib_unit, (char *) new_call_node(
  874.           assoc_symbol_get(unit_unam, INIT_BODY), tup_new(0), symbol_none));
  875.     }
  876. }
  877.  
  878. static int depth_level(char *stub_name)                        /*;depth_level*/
  879. {
  880.     /* calculate the current nesting depth of the subunit by trailing down its
  881.      * parent chain until its ancestor os reached.
  882.      */
  883.  
  884.     int        level, parent;
  885.     char    *s_name;
  886.  
  887.     level = 1;
  888.     s_name = stub_name;
  889.     while (1) {
  890.         parent = stub_parent_get(s_name);
  891.         if (parent != 0) {
  892.             s_name = pUnits[parent]->name;
  893.             level++;
  894.         }
  895.         else {
  896.             break;
  897.         }
  898.     }
  899.     return level;
  900. }
  901.  
  902. static Tuple build_relay_sets(char *unit, int depth)    /*;build_relay_sets*/
  903. {
  904.     /*
  905.      * This procedure computes the relay sets for the subunits of unit.
  906.      * Yield the relay tables of all (direct or indirect) subunits of unit.
  907.      * Depth is the level of imbrication ofsubunits (1 if unit is not a
  908.      * subunit).
  909.      * u_xxx stands for unit xxx
  910.      * s_xxx stands for subunit xxx
  911.      * sl     stands for (relay) slot
  912.      * rs     stands for relay set
  913.      */
  914.  
  915.     Tuple    save_relay_set, save_local_reference_map;
  916.     Tuple    s_rs, u_rs, stubs_tup, s_table, return_tup;
  917.     Tuple    stubtup, tup;
  918.     Stubenv    ev;
  919.     struct unit *pUnit;
  920.     int        u_sl, s_sl, offset, seg_num, si;
  921.     Symbol    name;
  922.     Fortup    ft1, ft2;
  923.     char        *s_name;
  924.  
  925.     /******
  926.    save_local_reference_map = LOCAL_REFERENCE_MAP;
  927.    save_relay_set        = RELAY_SET;
  928.  
  929.    [-,-,-,-,-,-,[u_sl,LOCAL_REFERENCE_MAP]] = LIB_UNIT(unit);
  930.    if (is_subunit(unit)) {
  931.         [-,-,-,-,-,-,-,RELAY_SET,DANGLING_RELAY_SETS] = STUB_ENV(unit);
  932.         DATA_SEGMENT += DANGLING_RELAY_SETS;
  933.    }
  934.    else {
  935.         RELAY_SET = [];
  936.    }
  937.     ********/
  938.  
  939.     save_local_reference_map = tup_copy(LOCAL_REFERENCE_MAP);
  940.     save_relay_set        = tup_copy(RELAY_SET);
  941.  
  942.     pUnit = pUnits[unit_numbered(unit)];
  943.     u_sl = (int)pUnit->libInfo.currCodeSeg;
  944.     LOCAL_REFERENCE_MAP = tup_copy((Tuple) pUnit->libInfo.localRefMap);
  945.  
  946.     if (is_subunit(unit) && !is_generic(unit)) {
  947.         si = stub_numbered(unit);
  948.         stubtup = (Tuple) stub_info[si];
  949.         ev = (Stubenv) stubtup[2];
  950.         RELAY_SET = tup_copy(ev->ev_relay_set);
  951.         DANGLING_RELAY_SETS = tup_copy(ev->ev_dangling_relay_set);
  952.         FORTUP(seg_num = (int), DANGLING_RELAY_SETS, ft1);
  953.         segment_put_int(DATA_SEGMENT, seg_num);
  954.         ENDFORTUP(ft1);
  955.     }
  956.     else {
  957.         RELAY_SET = tup_new(0);
  958.     }
  959.     /******
  960.    loop forall s_name in stubs(unit) | #s_name = depth+2 do
  961.     [s_sl, s_rs]   = build_relay_sets(s_name, depth+1);
  962.     s_table        = [reference_of(name)(2): name in s_rs];
  963.     DATA_SEGMENT += [s_sl, #s_table] + s_table;
  964.    end loop;
  965.     *****/
  966.  
  967.     stubs_tup = stubs(unit);
  968.     FORTUP(s_name = (char *), stubs_tup, ft1);
  969.         if (depth_level(s_name) != depth+1) continue;
  970.         tup = build_relay_sets(s_name, depth+1);
  971.         s_sl = (int) tup[1];
  972.         s_rs = (Tuple) tup[2];
  973.         s_table = tup_new(0);
  974.         FORTUP(name = (Symbol), s_rs, ft2);
  975.             reference_of(name);
  976.             s_table = tup_with(s_table, (char *) REFERENCE_OFFSET);
  977.         ENDFORTUP(ft2);
  978.         segment_put_int(DATA_SEGMENT, s_sl);
  979.         segment_put_int(DATA_SEGMENT, tup_size(s_table));
  980.         FORTUP(offset = (int), s_table, ft2);
  981.             segment_put_int(DATA_SEGMENT, offset);
  982.         ENDFORTUP(ft2);
  983.     ENDFORTUP(ft1);
  984.     /******
  985.    u_rs               = RELAY_SET;
  986.    RELAY_SET           = save_relay_set;
  987.    LOCAL_REFERENCE_MAP = save_local_reference_map;
  988.    return [u_sl, u_rs];
  989.     *****/
  990.     u_rs         = tup_copy(RELAY_SET);
  991.     RELAY_SET         = save_relay_set;
  992.     LOCAL_REFERENCE_MAP     = save_local_reference_map;
  993.     return_tup = tup_new(2);
  994.     return_tup[1] = (char *) u_sl;
  995.     return_tup[2] = (char *) u_rs;
  996.     return return_tup;
  997. }
  998.  
  999. static void update_subunit_context(char *subunit)    /*;update_subunit_context*/
  1000. {
  1001.     Set        stub_context, precedes;
  1002.     char        *ancestor_body;
  1003.     int        ancestor_num, unum, subunit_num;
  1004.     Forset    fs1;
  1005.     int        has_ancestor, i;
  1006.  
  1007.     /* Add the library units mentioned in the context clause for the subunit
  1008.      * to the precedes map for the ancestor unit of the stub since all the units
  1009.      * in the context clause need to be elaborated before the ancestor.
  1010.      */
  1011.  
  1012.     subunit_num = unit_numbered(subunit);
  1013.     stub_context = precedes_map_get(subunit);
  1014.     /* if the unit has not been loaded return */
  1015.     if (stub_context == (Set)0) return;
  1016.     ancestor_body = strjoin("bo", stub_ancestor(subunit));
  1017.     /* determine if the ancestor unit is package or subprogram */
  1018.     has_ancestor = FALSE;
  1019.     for (i = 1; i <= unit_numbers; i++)
  1020.         if (streq(ancestor_body, pUnits[i]->libUnit)) {
  1021.             has_ancestor = TRUE;
  1022.             break;
  1023.         }
  1024.     if (!has_ancestor)
  1025.         ancestor_body = strjoin("su", stub_ancestor(subunit));
  1026.     ancestor_num = unit_numbered(ancestor_body);
  1027.     precedes = precedes_map_get(ancestor_body);
  1028.     FORSET(unum = (int), stub_context, fs1);
  1029.         /* add in units that were in context clause of subunit so exclude
  1030.          * subunits which happen to be in the PRE_COMP field of this subunit.
  1031.          */
  1032.         if (!is_subunit(pUnits[unum]->name) && unum != ancestor_num)
  1033.             precedes = set_with(precedes, (char *)unum);
  1034.     ENDFORSET(fs1);
  1035.     precedes_map_put(ancestor_body, precedes);
  1036. }
  1037.  
  1038. static int load_binding_unit(char *unit)                /*;load_binding_unit*/
  1039. {
  1040.     char    *fname;
  1041.     int        file_retrieved;
  1042.     Unitdecl    ud;
  1043. #ifdef vms_BINDER
  1044.     struct      dsc$descriptor_s unit_name_desc;
  1045. #endif
  1046.     /* When binding is done load the necessary units if they are not loaded 
  1047.      * already. However, when a unit is to be loaded use read_binding_ais so 
  1048.      * that only the absolute necessary components of the ais are read.
  1049.      */
  1050.     fname = lib_unit_get(unit);
  1051.     if (fname == (char *)0) {
  1052. #ifdef vms
  1053.         if (adacomp_option)
  1054.             user_error(strjoin(formatted_name(unit)," not present in library"));
  1055.         else {
  1056.             unit_name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  1057.             unit_name_desc.dsc$b_class = DSC$K_CLASS_S;
  1058.             unit = formatted_name(unit);
  1059.             unit_name_desc.dsc$a_pointer = unit;
  1060.             unit_name_desc.dsc$w_length = strlen(unit);
  1061.             LIB$SIGNAL(MSG_NOTINLIB, 1, &unit_name_desc);
  1062.             LIB$SIGNAL(MSG_BINDABORT);
  1063.         }
  1064. #else
  1065.         user_error(strjoin(formatted_name(unit), " not present in library"));
  1066. #endif
  1067.         return FALSE;
  1068.     }
  1069.     else if (in_aisunits_read(unit)) {
  1070.         file_retrieved = TRUE;
  1071.     }
  1072.     else {
  1073.         file_retrieved = (read_binding_ais(fname, unit) != (char *)0);
  1074.         if (is_subunit(unit)) read_stub(lib_unit_get(unit), unit, "st2");
  1075.     }
  1076.  
  1077.     if (file_retrieved && (ud = unit_decl_get(unit)) != (Unitdecl)0) {
  1078.         return TRUE;
  1079.     }
  1080.     else {
  1081. #ifdef vms
  1082.         if (adacomp_option) {
  1083.             user_error(strjoin("Cannot retrieve unit ", formatted_name(unit)));
  1084.             user_info(strjoin(" from file ", fname));
  1085.         }
  1086.         else {
  1087.             unit_name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
  1088.             unit_name_desc.dsc$b_class = DSC$K_CLASS_S;
  1089.             unit = formatted_name(unit);
  1090.             unit_name_desc.dsc$a_pointer = unit;
  1091.             unit_name_desc.dsc$w_length = strlen(unit);
  1092.             LIB$SIGNAL(MSG_RETRIEVE, 1, &unit_name_desc);
  1093.             LIB$SIGNAL(MSG_BINDABORT);
  1094.         }
  1095. #else
  1096.         user_error(strjoin("Cannot retrieve unit ", formatted_name(unit)));
  1097.         user_info(strjoin(" from file ", fname));
  1098. #endif
  1099.         return FALSE;
  1100.     }
  1101. }
  1102.  
  1103. static char *read_binding_ais(char *fname, char *uname)  /*;read_binding_ais*/
  1104. {
  1105.     long    rec, genoff;
  1106.     int        fnum, unum, n, nodes, symbols, i, is_main_unit;
  1107.     Tuple    symptr, tup;
  1108.     struct unit *pUnit;
  1109.     char    *funame, *retrieved ;
  1110.     Unitdecl    ud;
  1111.     IFILE    *ifile;
  1112.     Symbol    sym;
  1113.     char     *lname, *tname;
  1114.     int        is_predef; /* set when reading predef file */
  1115.  
  1116.     /* This is a modified version of read_ais, which reads only the neccesary
  1117.      * items needed for binding. All other information is skipped.
  1118.      */
  1119.  
  1120.     retrieved = (char *)0;
  1121.     is_predef = streq(fname, "0");
  1122.     if (is_predef) {
  1123.         fname = "predef" ;
  1124.         lname= libset(PREDEFNAME);/* use predefined library */
  1125.     }
  1126.     ifile = ifopen(fname, "axq", "r", "a", iot_ais_r, 0);
  1127.     if (is_predef) {
  1128.         tname= libset(lname); /* restore library name */
  1129.     }
  1130.     for (rec = read_init(ifile); rec != 0; rec = read_next(ifile, rec)) {
  1131.         funame = getstr(ifile, "unit-name");
  1132.         if (uname != (char *)0  && streq(uname, funame) == 0) continue;
  1133.         fnum = getnum(ifile, "unit-number");
  1134.         unum = unit_number(funame);
  1135.         if (unum != fnum)
  1136.             chaos("read_ais sequence number error");
  1137.         genoff = getlong(ifile, "code-gen-offset");
  1138.         is_main_unit = streq(unit_name_type(funame), "ma");
  1139.         if (!is_main_unit) { /* read only if NOT main unit (it has no ais info*/
  1140.             symbols = getnum(ifile, "seq-symbol-n");
  1141.             nodes = getnum(ifile, "seq-node-n");
  1142.             pUnit = pUnits[unum];
  1143.             symptr = (Tuple)pUnit->aisInfo.symbols;
  1144.             if (symptr == (Tuple)0) { /* if tuple not yet allocated */
  1145.                 symptr = tup_new(symbols);
  1146.                 pUnit->aisInfo.symbols = (char *) symptr;
  1147.             }
  1148.  
  1149.             /* ELABORATE PRAGMA INFO */
  1150.             n = getnum(ifile, "pragma-info-size");
  1151.             tup = tup_new(n);
  1152.             for (i = 1; i <= n; i++) {
  1153.                 tup[i] = getstr(ifile, "pragma-info-value");
  1154.             }
  1155.             pUnit->aisInfo.pragmaElab = (char *)tup;
  1156.             /* UNIT_DECL */
  1157.             ud = unit_decl_new();
  1158.             pUnit->aisInfo.unitDecl = (char *)ud;
  1159.             sym = getsym(ifile, "ud-unam");
  1160.             ud->ud_unam = sym;
  1161.             ud->ud_useq = S_SEQ(sym);
  1162.             ud->ud_unit = S_UNIT(sym);
  1163.             get_unit_unam(ifile, sym);
  1164.             aisunits_read = tup_with(aisunits_read, funame);
  1165.         }
  1166.         retrieved = funame;
  1167.         break;
  1168.     }
  1169.     ifclose(ifile);
  1170.     return retrieved;
  1171. }
  1172.